The PC-SIG Library 10/The PC-Sig Library - Shareware for the IBM PC and Compatibles (PC-SIG)(Tenth Edition Disks 1-2804)(1991).iso/PC_SIGCD/02/1/DISK0217.ZIP/NELIST.PAS

Pascal/Delphi Source File | 1984-12-20 | 21KB | 626 lines

Program NELIST (input, Output);                                       {.CP32}
   {Lists TURBO Pascal programs on EpsonFX-80 numbering lines & marking
    reserved words, if requested.}
Const
   MaxLin: integer = 60;
Type
   TpFace   = (UndB,UndE,DblB,DblE,EmphB,EmphE,SmallB,SmallE,FF);
   ByteLine = array[0..3] of byte;
   Bytes    = Array[UndB..FF] of Byteline;
   Fil      = File of ByteLine;
   Str255   = string[255];
   Str14    = string[14];
   Str10    = string[10]; {Shd be large enough for longest reserved word}
   months   = string[4];
   Str3     = string[3];
   ResArr   = array[1..100] of str10;   {If adapting to another Pascal, this}
                           {type must be large enough for your ResWords File}
Var
   C:                 char;
   F:                 text;
   FileName:          Str14;
   Opening,Closing:   str3;
   DateLine:          string[25];
   Number:            string[16];
   Line:              str255;
   Day,I,LineNumber,
     PageLineNumber,
     Page,Year,NRes:  integer;
   Skip,Und,Emph,
      NumberLines:    Boolean;
   Reserv:            ResArr;
   Inst:              Bytes;
   T:                 TpFace;
   Istring:           array[UndB..SmallE] of str3;

Procedure BlankLine(I: integer);                                       {.CP5}
Begin
   GotoXY(12,I);
   Write('                                                         ')
End; {BlankLine}

Procedure Blank(Top,Bot: integer);                                     {.CP6}
Var
   I:              integer;
Begin
   For I := Top to Bot do BlankLine(I)
End; {Blank}

Procedure ByeBye;                                                     {.CP13}
Begin
   Blank(10,12); HighVideo;
   If Skip then begin
      GotoXY(32,10); write('That''s it, then.');
   End {if Skip}
   Else begin
      GotoXY(28-(length(FileName) div 2),10);
      write('Done.  ',FileName,' sent to printer.')
   End; {else}
   GotoXY(34,12); write('Signing Off.');
   GotoXY(1,22); LowVideo
End; {ByeBye}

Procedure Rectangle;                                                  {.CP20}
Var
   I: integer;
   HorU,HorL: string[60];
Begin
   HorU := ''; HorL := '';
   For I := 1 to 60 do HorU := Concat(HorU,Chr(220));
   For I := 1 to 60 do HorL := Concat(HorL,Chr(223));
   HighVideo;
   GotoXY(33,4); write('LISTER PROGRAM');
   LowVideo;
   gotoxy(11,5); writeln(HorU);
   For I := 6 to 19 do
   Begin
      GotoXY(11,I); Write(Chr(219));
      GotoXY(70,I); Write(Chr(219));
   End;
   GotoXY(11,20); write(HorL); HighVideo;
   GotoXY(28,21); writeln('Facit: R. N. Wisan   6/84'); LowVideo
End; {Rectangle}

Procedure Menu;                                                       {.CP10}

   Procedure CapName;                 {Capitalize File Name}
   Var
      I: integer;
   Begin
      for I := 1 to length(FileName) do
         If (Ord(FileName[I]) > 96) and (Ord(FileName[I]) < 123) then
            Filename[I] := Chr(Ord(FileName[I])-32)
   End; {CapName}

   Procedure timer; {Reads date & time from clock}                    {.CP15}
   type
      dt      =       record
                         yyyy:    1980..1999;
                         mo:      01..12;
                         dd:      01..31;
                         hh:      00..23;
                         mm:      00..59;
                         ss:      00..59;
                         hhh:     00..99;
                      end;
   Var
      DtRec:          dt;
      DateString:     string[14];
      TimeString:     string[8];

      procedure DateTime(var dtrec: dt);                              {.CP20}
      var
         regpack:        record
                            ax,bx,cx,dx,bp,si,di,ds,es,flags: integer;
                         end;
      begin
         with regpack do begin
            ax := swap($2C);
            intr ($21,regpack);
            dtrec.hh := (hi(cx));
            dtrec.mm := (lo(cx));
            dtrec.ss := hi(dx);
            dtrec.hhh := lo(dx);
            ax := swap($2A);
            intr ($21,regpack);
            dtrec.yyyy := cx;
            dtrec.mo := hi(dx);
            dtrec.dd := lo(dx);
         end; {with}
      end; {DateTime}

      Procedure MakeDateString;                                       {.CP31}
      Var
         Temp:        string[20];
         Month:       string[4];

         Procedure MakeMonthString;
         Begin
            Case dtrec.mo of
               1: Month := 'Jan.';
               2: Month := 'Feb.';
               3: Month := 'Mar.';
               4: Month := 'Apr.';
               5: Month := 'May' ;
               6: Month := 'June';
               7: Month := 'July';
               8: Month := 'Aug.';
               9: Month := 'Sep.';
              10: Month := 'Oct.';
              11: Month := 'Nov.';
              12: Month := 'Dec.'
            End {case}
         End;  {MakeMonthString}

      Begin {MakeDateString}
         MakeMonthString;
         DateString := Month;
         Str(Dtrec.dd,Temp);
         DateString := DateString + ' ' + Temp;
         Str(Dtrec.yyyy,Temp);
         DateString := DateString + ', ' + Temp;
      End; {MakeDateString}

      Procedure MakeTimeString;                                       {.CP19}
      Var
         Temp :       string[20];
         Merid:       string[3];
      Begin
         If Dtrec.hh>11 then begin
            Merid := ' pm';
            Dtrec.hh := Dtrec.hh - 12
         End {if}
         else Merid := ' am';
         If Dtrec.hh = 0 then Dtrec.hh := 12;
         Str(Dtrec.hh,TimeString);
         if Dtrec.ss>30 then Dtrec.mm := Dtrec.mm + 1;
         if Dtrec.mm<10 then
            TimeString := TimeString + ':0'
         else TimeString := TimeString + ':';
         Str(Dtrec.mm,Temp);
         TimeString := TimeString + Temp + Merid
      End; {MakeTimeString}

   Begin {Timer}                                                       {.CP9}
      DateTime(DtRec);
      MakeDateString;
      MakeTimeString;
      DateLine := DateString + ' (' + TimeString + ')';
      HighVideo;
      GotoXY(40-(Length(DateLine) div 2),18); Write(DateLine);
      LowVideo
   End; {Timer}

   Procedure EnterName;                                               {.CP37}
   Var
      I: integer;
      Ans: char;

      Procedure GetAns;
      Begin
         Repeat
            BlankLine(12);
            GotoXY(25,10); write('What File do you want to list?');
            GotoXY(34,12); read(Filename);
            Capname;
            If FileName='NONE' then begin
               Skip := TRUE;
               Ans := 'Y'
            End {if}
            Else Skip := FALSE;
            If not Skip then begin
               If Pos('.',Filename)=0 then
                  If Pos(':',Filename)=0 then
                     If length(Filename)<9 then
                        Filename := Concat(Filename,'.PAS')
                     Else
                        Filename :=
                           Concat(Copy(Filename,1,8),'.',Copy(Filename,9,3))
                  Else
                     If length(Filename)<11 then
                        Filename := Concat(Filename,'.PAS')
                     Else Filename :=
                        Concat(Copy(Filename,1,10),'.',Copy(Filename,11,3));
               BlankLine(12);
               GotoXY((33-length(Filename) div 2),12);
               write('Listing: ',Filename,', OK? ');
               Read(Trm,Ans);
            End {if not Skip}
         Until (Ans='Y') or (Ans='y')
      End; {GetAns}

      Procedure CheckFileName;                                        {.CP18}
      Begin
         Assign(F,Filename);
         {$I-} Reset(F) {$I+};
         I := IOresult;
         If I=2 then Begin
            Blank(9,12);
            GotoXY(33-(Length(Filename) div 2),9);
            write(Filename,' does not exist');
            EnterName
         End {If error #1 (have to call it #2 --glitch?}
         Else if I<>0 then Begin
            Blank(9,12);
            GotoXY(26,10);
            write('HELP! HELP!  Error #',I,' - maybe');
            Halt
         End {Else if other error}
      End; {CheckFileName}

   Begin {EnterName}                                                  {.CP10}
      HighVideo;
      GetAns;
      If not Skip then begin
         CheckFileName;
         If FileName[2]=':' then Filename := Copy(FileName,3,14);
         LowVideo;
         Blank(9,12)
      End {if not Skip}
   End; {EnterName}

   Procedure Options;                                                 {.CP14}
   Var
      I,Row: integer;
      Okay,FirstRound: Boolean;
      Ans: string[2];
      Yep: char;

      Procedure OptionsBillboard;
      Begin
         GotoXY(24,Row);   write('Options: L for Line Numbering');
         GotoXY(24,Row+1); write('         U for Underline KeyWords');
         GotoXY(24,Row+2); write('         E for Emphasize KeyWords');
         GotoXY(37,Row+3); read(Trm,Ans);
      End; {OptionsBillboard}

      Procedure ReadOptionsBill;                                      {.CP28}
      Begin
         If Pos(' ',Ans)=2 then Ans := Ans[1];
         If (Pos(' ',Ans)=1) and (Length(Ans)>1) then Ans := Ans[2];
         For I := 1 to Length(Ans) do if (Ans[I]>='a') and (Ans[I]<='z')
            then Ans[I] := chr(ord(Ans[I])-32);
         I := Length(Ans);
         Case I of
            0: Okay := True;
            1: If (Ans='L') or (Ans='U') or (Ans='E') or (Ans=' ')
                  then  Okay := True else Okay := False;
            2: If (Pos('L',Ans)<>0) and
                  ((Pos('U',Ans)<>0) or  (Pos('E',Ans)<>0))
                  then Okay := True else Okay := False;
         End; {Case}
         If not Okay then Begin
            Blank(8,Row+3);
            FirstRound := False; Row := 12;
            GotoXY(31,8); write('Say again, please:');
            GotoXY(24,9); write('You can have L and either U or E');
            If (Pos('U',Ans)<>0) and (Pos('E',Ans)<>0) then Begin
               GotoXY(25,10); write('(You can''t have BOTH U and E)')
            End  {if}
            Else Begin
               GotoXY(23,10); write('(or enter a blank & have it plain)')
            End {else}
         End {if not}
      End; {ReadOptionsBill}

      Procedure CheckOptions;                                         {.CP23}
      Begin
         If Pos('L',Ans)<>0 then NumberLines := True
            else Numberlines := False;
         If Pos('U',Ans)<>0 then Und := True else Und := False;
         If Pos('E',Ans)<>0 then Emph := True else Emph := False;
         If FirstRound then Blank(10,13) else Blank(8,Row+3);
         GotoXY(24,10); Write('You want to ');
         GotoXY(29,11);
         If Und then write('A  Underline key words.')
            else if Emph then write('A  Emphasize key words.')
            else write('A  Leave the key words plain.');
         GotoXY(29,12); write('B  ');
         If NumberLines then writeln('Number the lines.')
            else write ('Leave the lines unnumbered.');
         GotoXY(24,14); write('Is that correct? ');
         Read(trm,Yep);
         BlankLine(14);
         If not (Yep in ['Y','y']) then Begin
            FirstRound := True;
            Options;
         End; {if}
      End; {CheckOptions}

   Begin {Options}                                                    {.CP11}
      HighVideo;
      FirstRound := True;
      Row := 10;
      Repeat
         OptionsBillboard;
         ReadOptionsBill
      until Okay;
      CheckOptions;
      LowVideo
   End; {Options}

Begin  {Menu}                                                         {.CP11}
   Timer;
   Entername;
   If not skip then begin
      Blank(10,12);
      Options;
   End; {if not Skip}
   LowVideo
End;  {Menu}

Procedure PrintHeader;             {Print header line}                {.CP18}
Var
   Headline, Opener: string[80];
Begin
   Writeln(Lst,' ');
   If Numberlines then write(Lst,Istring[SmallE]);          {Set normal Pica}
   If Page = 1 then Headline := DateLine
   else
   Begin
      Str(Page,Headline);
      Headline := Concat('Page ',Headline);
   End; {else}
   Opener := Concat('File: ',FileName);
   writeln(Lst,Opener, Headline:80-length(opener));
   IF NumberLines then write(Lst,Istring[SmallB]);    {Set elite}
   writeln(Lst);
   Page := Page + 1;
End; {PrintHeader}

Procedure PrintControl(var PageLineNumber: integer);                  {.CP20}
Var
   Sym: string[8];
   S: array[1..8] of char;
   Col, I, J, Err: integer;
Begin
   IF pos(Concat('{.','PA}'),Line)<>0 then PageLineNumber :=MaxLin;
   IF pos(Concat('{.','CP'),Line) <>0 then
   Begin
      I := pos(Concat('{.','CP'),Line) + 4; Col := 1;
      For J := 1 to 8 do S[J] := Chr(0);
      Repeat
         S[Col] := Line[I];
         Col := Col + 1; I := I + 1;
       Until Line[I] = '}';
       Sym := S;
       Val(sym,I,Err);
       IF PageLineNumber > (MaxLin-I) then PageLineNumber := MaxLin;
    End {if}
End; {PrintControl}

Procedure CantCont(FilNam: Str14);                                     {.CP9}
Begin
   Blank(10,12); HighVideo;
   GotoXY(27,10); write('     Can''t continue      ');
   GotoXY(27,12); write('Error reading ',FilNam);
   GotoXY(27,13); write('Is it on the default disk?');
   LowVideo; GotoXY(1,23);
   Halt
End; {CantCnt}

Procedure GetTypeStyle;                                               {.CP12}
Var
   F:              Fil;
Begin
   Assign(F,'NEPRN.DAT');
   {$I-} Reset(F) {$I+};
   If IOresult=0 then Begin
      For T := UndB to FF do If not Eof(F) then read(F,Inst[T]);
      Close(F);
   End {If no error}
   Else CantCont('NEPRN.DAT')
End; {GetTypeStyle}

Procedure SetStyle;                                                   {.CP25}
Var
   I:              integer;
   T:              TpFace;
Begin
   For T := UndB to SmallE do Begin
      Istring[T] := '';
      For I := 1 to Inst[T,0] do Istring[T] := Istring[T] + Chr(Inst[T,I])
   End; {For T}
   If Und then Begin
      Opening := Istring[UndB];                    {Start underlining}
      Closing := Istring[UndE]                     {Stop underlining}
   end; {if Und}
   If Emph then Begin
      If NumberLines then Begin
         Opening := Istring[DblB];                 {Start double strike}
         Closing := Istring[DblE]                  {Stop double strike}
      end {if}
      else Begin
         Opening := Istring[EmphB];                {Start "Emphasized" type}
         Closing := Istring[EmphE]                 {Stop "Emphasized" type}
      end {else}
   End; {If Emph}
   If NumberLines then write(Lst,Istring[SmallE])  {Set elite mode}
End; {SetStyle}

Procedure LoadReserv(Var Reserv: ResArr);  {Load reserved words file} {.CP21}
  {If you're adapting this to a Pascal other than TURBO 1.00, make your own}
  {list of reserved words in file, RESWORDS.TXT, make sure Type str10 is as
  {long as your longest reserved word and Type ResArr has room enough.}
Var
   Fil: text;
   I: integer;
Begin
   Assign(Fil,'RESWORDS.TXT');
   {$I-} Reset(Fil) {$I+};
   If IOresult=0 then Begin
      I := 0;
      While not Eof(Fil) do begin
         I := I + 1;
         Readln(Fil,Reserv[I]);
      End; {while}
      Close(Fil);
      NRes := I
   End {if no error}
   Else CantCont('RESWORDS.TXT')
End; {LoadReserve}

Procedure ReadingMatter;                                               {.CP9}
Begin
   Blank(9,13);
   HighVideo;
   GotoXY(30-(Length(FileName) div 2),12); write('Sending ');
   TextColor(31);
   write(FileName);
   TextColor(15);
   Write(' to printer.');
   LowVideo
End; {ReadingMatter}

Procedure ListIt;                                                     {.CP20}
var
   Pager:          integer;
   Quote,DblComm,
      Comm:        boolean;

   Procedure Underline (var Line: str255);
   Var
      I,J: integer;
      Lc,Object: str255;
      Und,Emph,NumberLines: Boolean;

      Procedure LowCase(var S: str255);            {Convert S to lower case}
      Const
         Change: set of char = ['A'..'Z'];
      Var
         I:           byte;
      Begin
         for I := 1 to length(S) do
            if S[I] in Change then S[I] := Chr(ord(S[I]) or 32)
      end; {LowCase}

      Procedure Ins (var Obj:str10; var Line,Lc:str255; Op,Cl:Str3);  {.CP38}
      Const
         Markers: set of char =  [' ','.',';','['];
      var
         LcTemp,Temp:        str255;
         Posit,Len,Fin:     integer;
         Fore, Aft:          boolean;
         Pre, Post:          char;
      begin
         Temp := ''; LcTemp := '';
         Len := Length(Obj);
         While Pos(Obj,Lc)<>0 do begin
            Pre := 'z'; Post := 'z';
            Posit := Pos(Obj,Lc); Fin := Posit+Len-1;
            If Posit=1 then Pre := ' '                    {beginning of Lc}
               else Pre := Lc[Posit-1];
            If Fin = Length(Lc) then Post := ' '          {end of Lc}
               else Post := Lc[Fin+1];
            If Post in Markers then Aft := True
               else Aft := False;
            If (Pre=' ') then Fore := True
               else Fore := False;
            If Fore and Aft then begin
               If Posit>1 then begin
                  Temp := Concat(Temp,Copy(Line,1,Posit-1));
                  LcTemp := Concat(LcTemp,Copy(Lc,1,Posit-1))
               End; {if Posit>1}
               Temp := Concat(Temp,Op,Copy(Line,Posit,Len),Cl);
               LcTemp := Concat(LcTemp,Op,Copy(Lc,Posit,Len),Cl)
            end {if Fore & Aft}
            else begin
               Temp := Concat(Temp,Copy(Line,1,Fin));
               LcTemp := Concat(LcTemp,Copy(Lc,1,Fin))
            end; {else}
            Delete(Lc,1,Fin); Delete(Line,1,Fin)
         End; {While}
         Lc := Concat(LcTemp,Lc);
         Temp := Concat(Temp,Line);
         Line := Temp
      End; {Procedure Ins}

      Function Comb(Line: str255): str255;                            {.CP11}
      Var
         I,J: integer;

         Procedure CkComm;
         Begin
            if Line[I]='{' then Comm := True;
            If (Line[I]='(') and (Line[I+1]='*') then DblComm := True;
            If Line[I]='}' then Comm := False;
            If (Line[I]='*') and (Line[I+1]=')') then DblComm := False
         End; {CkComm}

      Begin {Comb}                                                    {.CP12}
         For I := 1 to length(Line) do begin
            if (Line[I]=chr(39)) and not(Comm or DblComm) then
               Quote := not Quote;
            If not Quote then CkComm;
            If (Line[I]=Opening[1]) and (Quote or Comm or DblComm) then begin
               delete(Line,I,length(Opening));
               Insert(closing,Line,I)
            end {if}
         End; {For I}
         Comb := Line
      End; {Comb}

   Begin {Underline}                                                   {.CP7}
      Lc := Line;
      LowCase(Lc);
      For I := 1 to NRes do Ins(Reserv[I],Line,Lc,Opening,Closing);
      If ((Pos(Chr(39),Line) + Pos('{',Line) + Pos('(*',Line))<>0)
         or Quote or Comm or DblComm then Line := Comb(Line);
   End; {Underline}

   Procedure PrintLine;               {Print one line}                {.CP13}
   Begin
      If Line<>'' then
      Begin
         If (NumberLines) then begin
            Str(LineNumber,Number);
            write(Lst,Number:5,' ':9)
         End; {If Numberlines}
         If Und or Emph then Underline(Line)
      End; {If Line is not blank}
      writeln(Lst,Line);
      LineNumber := LineNumber + 1
   End; {PrintLine}

   Procedure NewPage;                                                  {.CP7}
   Var
      K:           integer;
   Begin
      If Inst[FF,1]=12 then write(Lst,Char(12))
      Else For K := Pager to Inst[FF,1] do writeln(Lst,' ')
   End; {NewPage}

Begin {ListIt}                                                        {.CP19}
   LineNumber := 1; PageLineNumber := 3; Page := 1;
   Quote := False; Comm := False; DblComm := False;
   PrintHeader;
   While not EOF(F) do Begin
      Readln(F,Line);
      PageLineNumber := PageLineNumber + 1;
      Pager := PageLineNumber;
      If pos('{.',Line)<>0 then PrintControl(PageLineNumber);
      If (PageLineNumber >= MaxLin) then Begin
         NewPage;
         PrintHeader;
         PageLineNumber := 4;
      End; {If (PageLine}
      PrintLine;
   End; {While}
   If Numberlines then write(Lst,Istring[SmallE]);   {Printer back to normal}
   Pager := PageLineNumber + 1;
   NewPage
End; {ListIt}

Begin {Main}                                                          {.CP13}
   ClrScr;
   Rectangle;
   GetTypeStyle;
   LoadReserv(Reserv);
   Menu;
   If not Skip then begin
      If Und or Emph or NumberLines then SetStyle;
      ReadingMatter;
      ListIt;
   End; {if not Skip}
   ByeBye;
End. {Main}